Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/picedi1a/picedit.frm

Visual Basic Form | 1999-07-26 | 15.8 KB | 510 lines

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmPicEdit
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000004&
   Caption         =   "Overlay text on picture"
   ClientHeight    =   5205
   ClientLeft      =   1515
   ClientTop       =   3030
   ClientWidth     =   5010
   ClipControls    =   0   'False
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "PicEdit.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   OLEDropMode     =   1  'Manual
   ScaleHeight     =   5205
   ScaleWidth      =   5010
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   4080
      Top             =   120
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton CmdOverlayText
      Height          =   405
      Left            =   810
      Picture         =   "PicEdit.frx":000C
      Style           =   1  'Graphical
      TabIndex        =   11
      ToolTipText     =   "Proceed overlay"
      Top             =   180
      Visible         =   0   'False
      Width           =   405
   End
   Begin VB.CommandButton cmdTextFont
      Height          =   405
      Left            =   1440
      Picture         =   "PicEdit.frx":010E
      Style           =   1  'Graphical
      TabIndex        =   1
      ToolTipText     =   "Select text font"
      Top             =   180
      Width           =   405
   End
   Begin VB.CommandButton cmdTextColor
      Height          =   405
      Left            =   2070
      Picture         =   "PicEdit.frx":0908
      Style           =   1  'Graphical
      TabIndex        =   2
      ToolTipText     =   "Select text color"
      Top             =   180
      Width           =   405
   End
   Begin VB.CommandButton cmdInputText
      Height          =   405
      Left            =   810
      Picture         =   "PicEdit.frx":0F72
      Style           =   1  'Graphical
      TabIndex        =   3
      ToolTipText     =   "Input text"
      Top             =   180
      Width           =   405
   End
   Begin VB.CommandButton cmdClose
      Height          =   405
      Left            =   3360
      Picture         =   "PicEdit.frx":1074
      Style           =   1  'Graphical
      TabIndex        =   5
      ToolTipText     =   "Close"
      Top             =   180
      Width           =   405
   End
   Begin VB.CommandButton cmdSave
      Height          =   405
      Left            =   2730
      Picture         =   "PicEdit.frx":186E
      Style           =   1  'Graphical
      TabIndex        =   4
      ToolTipText     =   "Save"
      Top             =   180
      Width           =   405
   End
   Begin VB.CommandButton cmdOpen
      Height          =   405
      Left            =   180
      Picture         =   "PicEdit.frx":1ED8
      Style           =   1  'Graphical
      TabIndex        =   0
      ToolTipText     =   "Open graphics file"
      Top             =   180
      Width           =   405
   End
   Begin VB.HScrollBar HScroll1
      Height          =   345
      Left            =   0
      TabIndex        =   8
      Top             =   6360
      Width           =   10755
   End
   Begin VB.PictureBox PicZ
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000006&
      Height          =   3135
      Left            =   180
      ScaleHeight     =   205
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   301
      TabIndex        =   6
      Top             =   1800
      Width           =   4575
      Begin RichTextLib.RichTextBox rtbText
         Height          =   465
         Left            =   120
         TabIndex        =   10
         Top             =   2610
         Visible         =   0   'False
         Width           =   1815
         _ExtentX        =   3201
         _ExtentY        =   820
         _Version        =   393217
         BackColor       =   16777215
         BorderStyle     =   0
         Enabled         =   -1  'True
         HideSelection   =   0   'False
         Appearance      =   0
         OLEDragMode     =   0
         OLEDropMode     =   0
         TextRTF         =   $"PicEdit.frx":1FDA
      End
      Begin VB.PictureBox PicX
         AutoRedraw      =   -1  'True
         BorderStyle     =   0  'None
         Height          =   2085
         Left            =   0
         ScaleHeight     =   2085
         ScaleWidth      =   4035
         TabIndex        =   9
         Top             =   0
         Width           =   4035
      End
      Begin VB.PictureBox PicY
         AutoRedraw      =   -1  'True
         BackColor       =   &H8000000E&
         BorderStyle     =   0  'None
         Height          =   2580
         Left            =   0
         ScaleHeight     =   2580
         ScaleWidth      =   4500
         TabIndex        =   7
         Top             =   0
         Visible         =   0   'False
         Width           =   4500
      End
   End
   Begin VB.Label Label1
      Caption         =   "Label1"
      Height          =   855
      Left            =   180
      TabIndex        =   12
      Top             =   750
      Width           =   4545
   End
Attribute VB_Name = "frmPicEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' PicEdit.frm
' By Herman Liu
' To show how one can place rich text on graphics, in a simple way. (VB seperates
' rich text and picture as distinctly different types of format, and does not
' provide functions to allow superimposing the former on the latter). This code
' enables the user to directly input text (type on screen or through clipboard)
' at any point on picture, with options of text font size and color.
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
     (ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, Ip As Any) As Long

Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type CharRange
    firstChar As Long
    lastChar As Long
End Type
Private Type FormatRange
    hdc As Long
    hdcTarget As Long
    rectRegion As Rect
    rectPage As Rect
    mCharRange As CharRange
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Dim mFormatRange As FormatRange
Dim rectDrawTo As Rect, rectPage As Rect
Dim TextLength As Long, newStartPos As Long
Dim dumpaway As Long
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
Dim NoPicFlag As Boolean, RegionFlag As Boolean
Dim fso As FileSystemObject
Private Sub Form_Load()
    Me.ScaleMode = vbTwips
    PicX.ScaleMode = vbTwips
    PicY.ScaleMode = vbTwips
    PicZ.ScaleMode = vbPixels
    PicZ.AutoSize = True
    PicX.AutoSize = True
    PicY.AutoSize = True
    PicZ.AutoRedraw = True
    PicX.AutoRedraw = True
    PicY.AutoRedraw = True
    PicZ.Visible = True
    PicX.Visible = True
    PicY.Visible = False
    PicZ.BorderStyle = 1
    PicX.BorderStyle = 0
    PicY.BorderStyle = 0
    PicZ.BackColor = &H80000006
    PicY.Top = PicX.Top
    PicY.Left = PicX.Left
    X1 = 0: Y1 = 0: X2 = 0: Y2 = 0
    CmdOverlayText.Visible = False
    Set fso = New FileSystemObject
    rtbText.Visible = False
    If fso.FileExists("\windows\clouds.bmp") Then
         PicX.Picture = LoadPicture("\windows\clouds.bmp", vbCFBitmap)
         NoPicFlag = False
    Else
         NoPicFlag = True
    End If
    PicY.Width = PicX.Width
    PicY.Height = PicX.Height
    PicY.Picture = PicX.Picture
    PicY.Move PicX.Top, PicX.Left
    Dim t
    t = "Steps: 1. Drag left-mouse on picture to frame a rectangle area."
    t = t & " 2. Click the second button to allow input of text in that"
    t = t & " area. 3. Type in text (you may select font and color)."
    t = t & " 4. Click the second button again."
    Label1.Caption = t
    RegionFlag = False
End Sub
Private Sub cmdInputText_Click()
    On Error GoTo errhandler
    RegionFlag = False
    If X2 - X1 <= 100 Or Y2 - Y1 <= 100 Then
         MsgBox "No text input region yet"
         Exit Sub
    End If
    If CmdOverlayText.Visible = True Then
         If Len(rtbText.Text) = 0 Then
             MsgBox "No text input yet"
             Exit Sub
         End If
         TextToPic
         Exit Sub
    End If
    If Clipboard.GetFormat(vbCFText) = True Then
         rtbText.Text = Clipboard.GetText
    Else
         rtbText.Text = "Type text here"
    End If

    ValidateDraw
    rtbText.Width = (X2 - X1) / Screen.TwipsPerPixelX + 2
    rtbText.Height = (Y2 - Y1) / Screen.TwipsPerPixelY + 2
    If rtbText.SelColor = vbWhite Then
        rtbText.BackColor = vbBlue
    Else
        rtbText.BackColor = vbWhite
    End If
    cmdInputText.Visible = False
    CmdOverlayText.Visible = True
    rtbText.Visible = True
    rtbText.Enabled = True
    rtbText.Move (X1 / Screen.TwipsPerPixelX), (Y1 / Screen.TwipsPerPixelY)
    rtbText.SetFocus
    cmdInputText.Visible = False
    CmdOverlayText.Visible = True
    Exit Sub
errhandler:
    ErrMsgProc "mnuFileOverlayText_Click"
End Sub
Private Sub TextToPic()
    RegionFlag = False
    If Len(rtbText.Text) = 0 Then
        Exit Sub
    End If
    rtbText.Visible = False
    rtbText.Enabled = False
    Overlaying
    PicY.Picture = PicY.Image
    PicX.Picture = PicY.Picture
    rtbText.Text = ""
    CmdOverlayText.Visible = False
    cmdInputText.Visible = True
End Sub
Private Sub Overlaying()
    On Error GoTo errhandler
    DoEvents
    Screen.MousePointer = vbHourglass
    rectPage.Left = X1
    rectPage.Top = Y1
    rectPage.Right = X2
    rectPage.Bottom = Y2
    rectDrawTo.Left = rectPage.Left
    rectDrawTo.Top = rectPage.Top
    rectDrawTo.Right = rectPage.Right
    rectDrawTo.Bottom = rectPage.Bottom
    mFormatRange.hdc = PicY.hdc
    mFormatRange.hdcTarget = PicY.hdc
    newStartPos = 0
    mFormatRange.rectRegion = rectDrawTo
    mFormatRange.rectPage = rectPage
    mFormatRange.mCharRange.firstChar = newStartPos
    mFormatRange.mCharRange.lastChar = -1
    TextLength = Len(rtbText.Text)
    Do
        newStartPos = SendMessage(rtbText.hwnd, EM_FORMATRANGE, True, mFormatRange)
        If newStartPos >= TextLength Then
            Exit Do
        End If
        mFormatRange.mCharRange.firstChar = newStartPos
        mFormatRange.hdc = PicY.hdc
        mFormatRange.hdcTarget = PicY.hdc
        DoEvents
    Loop
    dumpaway = SendMessage(rtbText.hwnd, EM_FORMATRANGE, False, ByVal CLng(0))
    Screen.MousePointer = vbDefault
    Exit Sub
errhandler:
    Screen.MousePointer = vbDefault
    ErrMsgProc "Overlaying"
End Sub
Private Sub Form_Unload(Cancel As Integer)
     End
End Sub
Private Sub picx_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
         rtbText.Visible = False
         CmdOverlayText.Visible = False
         cmdInputText.Visible = True
         RegionFlag = True
         PicX.DrawMode = vbInvert
         X1 = X: X2 = X: Y1 = Y: Y2 = Y
         PicX.Cls
         PicX.Line (X, Y)-(X, Y), , B
    End If
End Sub
Private Sub picX_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not RegionFlag Then
         Exit Sub
    End If
    PicX.Line (X1, Y1)-(X2, Y2), , B
    X2 = X
    Y2 = Y
    PicX.Line (X1, Y1)-(X2, Y2), , B
End Sub
Private Sub picX_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not RegionFlag Then
        Exit Sub
    Else
        RegionFlag = False
        PicX.DrawMode = vbCopyPen
    End If
End Sub
Private Sub ValidateDraw()
    Dim tmp As Single
    If X1 > X2 Then
        tmp = X1
        X1 = X2
        X2 = tmp
    End If
    If Y1 > Y2 Then
        tmp = Y1
        Y1 = Y2
        Y2 = tmp
    End If
End Sub
Private Sub cmdOpen_Click()
    On Error GoTo errhandler
    Dim mfilespec As String
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.FileName = ""
    CommonDialog1.Filter = ""
    CommonDialog1.CancelError = True
FileNameRetry:
    CommonDialog1.ShowOpen
    If CommonDialog1.FileName = "" Then
        Exit Sub
    End If

    If Not fso.FileExists(CommonDialog1.FileName) Then
        GoTo FileNameRetry
    End If
    mfilespec = CommonDialog1.FileName
    Screen.MousePointer = vbHourglass
    PicX.Cls
    PicY.Cls
    PicX.AutoSize = True
    PicY.AutoSize = True
    PicX.Picture = LoadPicture(mfilespec)
    PicY.Picture = PicX.Picture
    PicX.AutoSize = False
    PicY.AutoSize = False
    PicY.Move PicX.Top, PicX.Left
    rtbText.SelColor = vbBlack
    rtbText.BackColor = vbWhite
    NoPicFlag = False
    Screen.MousePointer = vbDefault
    Exit Sub
errhandler:
    PicX.AutoSize = False
    PicY.AutoSize = False
    Screen.MousePointer = vbDefault
    If Err <> 32755 Then
         ErrMsgProc "frmPicEdit LoadPicFile"
    End If
End Sub
Private Sub cmdTextFont_Click()
    On Error GoTo errhandler
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlCFBoth
    CommonDialog1.FontName = Screen.ActiveForm.FontName
    CommonDialog1.ShowFont
    rtbText.SelStart = 0
    rtbText.SelLength = Len(rtbText.Text)
    rtbText.SelFontName = CommonDialog1.FontName
    rtbText.SelFontSize = CommonDialog1.FontSize
    Exit Sub
errhandler:
    If Err.Number <> 32755 Then
        ErrMsgProc "mnuFileTextFont_click"
    End If
End Sub
Private Sub cmdTextColor_Click()
    On Error GoTo errhandler
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlCFBoth
    CommonDialog1.Color = Screen.ActiveForm.ForeColor
    CommonDialog1.ShowColor
    rtbText.SelStart = 0
    rtbText.SelLength = Len(rtbText.Text)
    rtbText.SelColor = CommonDialog1.Color
    If rtbText.SelColor = vbWhite Then
        rtbText.BackColor = vbBlue
    Else
        rtbText.BackColor = vbWhite
    End If
    Exit Sub
errhandler:
    If Err.Number <> 32755 Then
        ErrMsgProc "mnuFileTextColor"
    End If
End Sub
Private Sub cmdOverlayText_Click()
    cmdInputText_Click
End Sub
Private Sub cmdSave_Click()
    If NoPicFlag Then
         MsgBox "No picture loaded yet"
         Exit Sub
    End If
    On Error GoTo errhandler
    Dim mfilespec As String
    With CommonDialog1
        .FileName = mfilespec
        .Flags = cdlOFNHideReadOnly
        .ShowSave
    End With
    mfilespec = CommonDialog1.FileName
    If fso.FileExists(mfilespec) Then
         If MsgBox("File already exists.  Overwirte?", vbYesNo + vbQuestion) = vbNo Then
              Exit Sub
         End If
    End If
    Screen.MousePointer = vbHourglass
    SavePicture PicX.Picture, mfilespec
    Screen.MousePointer = vbDefault
    Exit Sub
errhandler:
    Screen.MousePointer = vbDefault
    If Err <> 32755 Then
         ErrMsgProc "frmPicEdit mnuFileSave_Click"
    End If
End Sub
Private Sub cmdClose_Click()
    End
End Sub
Sub ErrMsgProc(mMsg As String)
    MsgBox mMsg & vbCrLf & Err.Number & Space(5) & Err.Description
End Sub